# For Emacs: -*-mode:cperl;mode:folding-*-;
#
# Txtid.pm module exports common functions for Textid project
#
#

package Txtid;

# {{{ use block

use strict;
use warnings;

use Carp;
use Data::Dumper;
use IPC::Run3              qw(run3);
use Math::Round            qw(round);
use Perl6::Export::Attrs;
use Storable               qw(nstore);
use List::Util             qw(min);
use utf8::all;

# }}}

# text / data transformation functions

# {{{ extract_sentences

sub extract_sentences :Export(:DEFAULT){                                         # extract sentence from vcf /vertical corpora format/ file
    my $args_hr = shift;                                                         # and return sentence as an array reference
    my $FH      = $args_hr->{file};
    my $lines   = count_lines($args_hr->{path});
    my $regex   = '';

    if ($args_hr->{filter}) {
        for my $position ( keys %{$args_hr->{filter}} ) {
            my $string;
            if ($position != 1 ) {
                $string = '\w' . "{$position  - 1}$args_hr->{filter}->{$position}" . '\w*';   # if position > 1, we count previous positions in the tag
            }
            else {
                $string = "$args_hr->{filter}->{$position}" . '\w+';                          # we filter according to the first position in the tag
            }
            if ($regex =~ m{\w+}xms) {
                $regex = $regex . '&' . $string;                             # if regex contains any data, prepend the next filter with the logical 'and' conjunction to the regex
            }
            else {
                $regex = $string;                                            # otherway the regex is empty - and the string creates new regex
            }
        }
        $regex = qr{$regex}xms;
    }

    my $line;
    my $sentence_lr;
    my $sentence_rhythm_lr = [];
    my $text_lr;
    my $text_rhythm_lr = [];
    my $i;
    my $j = 0;

    while ($line = <$FH>) {
        chomp $line;
        $i++;
        print "extracting line [$i/$lines]\r" if $args_hr->{counter};

        if ($line !~ m{^<(.+?)>$}xms) {                                                                   # if VCF line contains language elements
            my ($w, $l, $t) = split m{\t}xms, $line;                                                      # split the VCF line into word, lemma and tag elements
            $w = lc $w;
            $l = lc $l;
            if ($t !~ $regex) {                                                                           # apply filter if exists
                $args_hr->{hook} =~ m{wform}xms ? push @{$sentence_lr}, $w : push @{$sentence_lr}, $l;    # create texts for comparsion from lemma or word form
                if ($t =~ m{^(?<pospeech>\w).+$}xms) {                                                    # match the first element (POS) of the tag
                    my $pos = $+{pospeech};
                    push @{$sentence_rhythm_lr}, $pos;                                                    # push the POS into the container
                }
            }
        }
        elsif ($line =~ m{^</s>$}xms) {                                                                   # if VCF line contains meta-language elements - end of sentence mark
            push @{$text_lr}, $sentence_lr;                                                               # push arref with words of the sentence to the text container
            push @{$text_rhythm_lr}, $sentence_rhythm_lr;                                                 # push POS representants to the text container
            $sentence_lr        = [];                                                                     # make the sentence container empty
            $sentence_rhythm_lr = [];                                                                     # make the rhythm container empty
        }
    }
    print "\n" if $args_hr->{counter};

    my $output_hr = {
        text   => $text_lr,                                                                               # $arref = [[a,b,c,],[d,q,w,w,a],[u,!]] etc.
        rhythm => $text_rhythm_lr,
    };

    return $output_hr;
}

# }}}
# {{{ get_histogram

sub get_histogram :Export(:DEFAULT) {
    my $tf_hr        = shift;
    my $histogram_hr = {};

    for my $type (keys  %{$tf_hr}) {
        my $frequency = $tf_hr->{$type};
        $histogram_hr->{$frequency}++;
    }

    return $histogram_hr;
}

# }}}
# {{{ get_tag

sub get_tag :Export(:DEFAULT) {
    my @log = @_;
    my %tag = ('word_order' => 'o', 'word_structure' => 's',
               'text'       => 't', 'morphology'     => 'm',);

    map { $_ = $tag{$_}  } @log;

    return \@log;
}

# }}}
# {{{ extract_ngrams

sub extract_ngrams :Export(:DEFAULT){
    my $tokens_lr = shift;
    my $size      = shift;

    my $ngrams_hr = {};
    my $max       = (scalar @{$tokens_lr} - 1);
    $size         = $size - 1;

    for my $index (0 .. $max) {                                           # loop through the array with all tokens
        my $string = '';                                                  # create an empty string
        if ( ($index + $size) <= $max) {                                  # the index of the token in the last n-gram can't have higher index then is the last element of the input array
            for my $j ($index .. ($index + $size)) {
                if ($string ne '') {                                            # if string is not empty, the token will stay on leading position
                    $string = $string . ' ' . $tokens_lr->[$j];           # if string contains data, prepand white space and next token
                }
                else {
                    $string = $tokens_lr->[$j];                           # token is placed on the leading position in the n-gram
                }
            }
            $ngrams_hr->{$string}++;
        }
    }

    return $ngrams_hr;
}

# }}}
# {{{ fisher-yates shuffle

sub fisher_yates_shuffle :Export(:DEFAULT) {                                                               # randomize members in an array: receipe 4.17. PerlCookbook
    my $data_lr   = shift;                                                                                 # get the listref with all sentences
    my $rhythm_lr = shift;
    my $ratio     = shift;

    my $i;
    if (! $ratio) {                                                                                      # if not ratio given, process all sentences
        $ratio = 100;
    }

    my $limit   = ( scalar @{$data_lr} / 100 ) * $ratio;                                                 # set the limit according to desired ratio
    $limit      = round($limit);                                                                         # get the nearest integer
    my $counter = 0;

    my $max     = scalar @{$data_lr};

    for my $index (0 .. ($max - 1)) {
        my $num_elements = scalar @{$data_lr->[$index]};
        if ($limit >= $counter && $num_elements > 1) {                                                  # if limit is lower/equal or if sentence array contains no elements
            for ($i = $num_elements; --$i; ) {                                                          # randomize members of the sentence
                my $j = int rand ($i+1);
                next if $i == $j;
                my $sentence_lr      = $data_lr->[$index];
                my $seq_lr           = $rhythm_lr->[$index];
                @$sentence_lr[$i,$j] = @$sentence_lr[$j,$i];
                @$seq_lr[$i,$j]      = @$seq_lr[$j,$i];
            }
        }
        $counter++;
    }

    return $data_lr;
}

# }}}
# {{{ modify_words

sub modify_words :Export(:DEFAULT){
    my $text_lr  = shift;

    for my $sentence (@{$text_lr}) {
        my $shuffled_sentence = [];
        for my $word (@{$sentence}) {
             my $sword = [ split m{}xms, $word ];

             my $i;
             for ($i = @{$sword}; --$i; ) {
                 my $j = int rand ($i+1);
                 next if $i == $j;
                 @{$sword}[$i,$j] = @{$sword}[$j,$i];
             }
             $word = join '', @{$sword};
        }
    }

    return $text_lr;
}

# }}}
# {{{ tokenize

sub tokenize :Export(:DEFAULT) {
    my $text      = shift;
    my $tokens_lr = [ split m{\s+|\n+}xms, $text ];

    return $tokens_lr;
}

# }}}

# functions for texts comparing

# {{{ compare_distributions

sub compare_distributions :Export(:DEFAULT){
    my $original_xr = shift;  # polymorphic argument
    my $modified_xr = shift;  # polymorphic argument

    my $o_tf_hr;
    my $m_tf_hr;

    if (ref $original_xr eq 'ARRAY') {
        $original_xr = flatten($original_xr);
        $modified_xr = flatten($modified_xr);
        $o_tf_hr     = transform_l2h($original_xr);
        $m_tf_hr     = transform_l2h($modified_xr);
    }
    else {
        $o_tf_hr = $original_xr;
        $m_tf_hr = $modified_xr;
    }

    for my $token ( keys %{$o_tf_hr} ) {                                  # only common tokens can go to the bh. dist. computation
        $m_tf_hr->{$token} = 0 if (! exists $m_tf_hr->{$token});
    }
    for my $token ( keys %{$m_tf_hr} ) {
            $o_tf_hr->{$token} = 0 if (! exists $o_tf_hr->{$token});
    }

    my $euclidean_distance = euclidean_distance($o_tf_hr,$m_tf_hr);

    return $euclidean_distance;
}

# }}}
# {{{ compare_rhythm

sub compare_rhythm :Export(:DEFAULT){
    my $original_lr = shift;
    my $deformed_lr = shift;

    my $levenshtein_distance;
    for my $index ( 0 .. @{$original_lr} ) {
        my $s1 = flatten($original_lr->[$index]);  # a sentence
        my $s2 = flatten($deformed_lr->[$index]);  # a sentence
        my $original = join '', @{$s1};
        my $deformed = join '', @{$s2};
        my $lev = levenshtein_distance($original,$deformed);
        $levenshtein_distance += $lev;
    }

    return $levenshtein_distance;
}

# }}}
# {{{ compare_tokens_frequencies

sub compare_tokens_frequencies :Export(:DEFAULT){
    my $original_xr = shift;
    my $modified_xr = shift;

    my $o_tf_hr;
    my $m_tf_hr;

    if (ref $original_xr eq 'ARRAY') {
        $original_xr = flatten($original_xr);
        $modified_xr = flatten($modified_xr);
        $o_tf_hr     = transform_l2h($original_xr);
        $m_tf_hr     = transform_l2h($modified_xr);
    }
    else {
        $o_tf_hr = $original_xr;
        $m_tf_hr = $modified_xr;
    }

    my $check_sum = get_sum($m_tf_hr);
    croak "Can't count the spearman correlation coefficient! The numeric vector has mean 1! \n"
        if ( $check_sum / ( keys %{$m_tf_hr} ) ) == 1;

    my $vector_lr = make_vector($o_tf_hr,$m_tf_hr);
    my $rho       = pearson_correlation($vector_lr);

    return $rho;
}

# }}}
# {{{ count_ttr

sub count_ttr :Export(:DEFAULT){
    my $original_xr = shift;
    my $modified_xr = shift;

    my $o_tf_hr;
    my $m_tf_hr;

    if (ref $original_xr eq 'ARRAY') {
        $original_xr = flatten($original_xr);
        $modified_xr = flatten($modified_xr);
        $o_tf_hr  = transform_l2h($original_xr);
        $m_tf_hr  = transform_l2h($modified_xr);
    }
    else {
        $o_tf_hr  = $original_xr;
        $m_tf_hr  = $modified_xr;
    }

    my @o_types  = keys %{$o_tf_hr};
    my @m_types  = keys %{$m_tf_hr};
    my $o_tokens = get_sum($o_tf_hr);
    my $m_tokens = get_sum($m_tf_hr);

    my $ttr_1    = scalar @o_types / $o_tokens;
    my $ttr_2    = scalar @m_types / $m_tokens;

    my $o = scalar @o_types;
    my $t = scalar @m_types;

    my $text  = [$ttr_1,$ttr_2];

    return $text;
}

# }}}

# distance metrics & statistical tools

# {{{ bhattacharyya_distance 'for discrete probability distributions'

sub bhattacharyya_distance :Export(:DEFAULT) {         # see http://en.wikipedia.org/wiki/Bhattacharyya_distance
    my $h1_hr = shift;
    my $h2_hr = shift;                                 # histogram 2 hash reference

    my $BC;                                            # Bhattacharyya coefficient

    my $s1 = get_sum($h1_hr);
    my $s2 = get_sum($h2_hr);

    for my $frequency (keys %{$h1_hr}) {
        if (exists $h2_hr->{$frequency}) {
           my $product = ($h1_hr->{$frequency} / $s1) * ($h2_hr->{$frequency} / $s2);
           $BC += (sqrt $product);
        }
    }
    my $b_distance = -(log $BC);

    return $b_distance;
}

# }}}
# {{{ get_sum

sub get_sum {
    my $href = shift;

    my $sum;
    for my $key (keys %{$href}) {
        my $val = $href->{$key};
        $sum += $val;
    }

    return $sum;
}

# }}}
# {{{ euclidean_distance

sub euclidean_distance :Export(:DEFAULT){
    my $histogram_orig_hr = shift;
    my $histogram_defm_hr = shift;

    my $sum = 0;
    for my $token ( keys %{$histogram_orig_hr} ) {
        my $sum_part   = $histogram_orig_hr->{$token} - $histogram_defm_hr->{$token};
        my $sum_square = $sum_part * $sum_part;
        $sum += $sum_square;
    }
    $sum = sqrt $sum;

    return $sum;
}

# }}}
# {{{ levenshtein

sub levenshtein_distance :Export(:DEFAULT){
    my ($str1, $str2) = @_;
    my $ar1       = [];
    my $ar2       = [];

    @{$ar1} = split //, $str1;
    @{$ar2} = split //, $str2;

    my $dist = [];

    $dist->[$_][0] = $_ for (0 .. @{$ar1});
    $dist->[0][$_] = $_ for (0 .. @{$ar2});

    for my $i (1 .. @{$ar1}){
        for my $j (1 .. @{$ar2}){
            my $cost = $ar1->[$i - 1] eq $ar2->[$j - 1] ? 0 : 1;
            $dist->[$i][$j] = min(
                $dist->[$i - 1][$j] + 1,
                $dist->[$i][$j - 1] + 1,
                $dist->[$i - 1][$j - 1] + $cost );
        }
    }

    return $dist->[@{$ar1}][@{$ar2}];
}

# }}}
# {{{ pearson_correlation

sub pearson_correlation :Export(:DEFAULT){
    my $vector_lr = shift;

    my $x_vector = [];
    my $y_vector = [];
    my ($sum_x, $sum_y, $i);
    my ($x_denominator, $y_denominator, $numerator);

    for my $pair ( @{$vector_lr} ) {
        push @{$x_vector}, $pair->[0];
        push @{$y_vector}, $pair->[1];
        $sum_x += $pair->[0];
        $sum_y += $pair->[1];
        $i++;
    }

    my $mean_x = $sum_x / $i;
    my $mean_y = $sum_y / $i;

    for my $index (0 .. ($i - 1) ) {
        $numerator     += ($x_vector->[$index] - $mean_x) * ($y_vector->[$index] - $mean_y);
        $x_denominator += ($x_vector->[$index] - $mean_x) ** 2;
        $y_denominator += ($y_vector->[$index] - $mean_y) ** 2;
    }
    my $rho = $numerator / ( ( sqrt $x_denominator ) * (sqrt $y_denominator ) );

    return $rho;
}

# }}}

# auxilliary functions

# {{{ count_lines

sub count_lines :Export(:DEFAULT){
    my $file = shift;
    my $l;
    my $lines = 0;


    open my $FH, '<:utf8', $file or croak "Can't open $file for reading!";

    while ($l = <$FH>) {
        chomp $l;
        $lines++;
    }

    close $FH;

    return $lines;
}

# }}}
# {{{ flatten

sub flatten :Export(:DEFAULT){
    my $arref = shift;
    my $container_lr = [];

    for my $sentence (@{$arref}) {
        if (ref $sentence eq 'ARRAY') {
            for my $word (@{$sentence}) {
                push @{$container_lr}, $word;
            }
        }
        if (ref $sentence eq '') {
            push @{$container_lr}, $sentence;
        }
    }

    return $container_lr;
}

# }}}
# {{{ invoke_child_process

sub run_process :Export(:DEFAULT) {
    my $cmd     = shift;
    my $stdin   = shift;
    my $stdout  = shift;
    my $stderr  = shift;
    my %options = ();
    run3($cmd, $stdin, $stdout, $stderr, \%options);

    return {
        stdout => $stdout,
        stderr => $stderr,
    };
}

# }}}
# {{{ make_vector

sub make_vector :Export(:DEFAULT){
    my $o_hr   = shift;
    my $m_hr   = shift;
    my $vector = [];

    for my $token (keys %{$o_hr}) {                 #prepare vector of common frequencies
        if (! exists $m_hr->{$token}) {
            $m_hr->{$token} = 0;                     # if given token does not appear in the opposite data structure, its fq is 0
        }
    }
    for my $token ( sort keys %{$m_hr}) {
        if (! exists $o_hr->{$token}) {
            $o_hr->{$token} = 0;
        }
        push @{$vector}, [$o_hr->{$token},$m_hr->{$token}];
    }

    return $vector;
}

# }}}
# {{{ open_file

sub open_file :Export(:DEFAULT) {
    my $name = shift;
    my $text;

    open my $FH, '<:utf8', $name or croak "Can't open file $name for reading!";
    { local $/ = undef; $text = <$FH>; };
    close $FH;

    return $text;
}

# }}}
# {{{ transform_actions

sub transform_actions :Export(:DEFAULT) {
    my $action_list_lr = shift;
    my $actions_lr;
    my $actions_hr = {};

    $actions_lr = [ split m{,}x, join ',', @{$action_list_lr} ];
    map { $actions_hr->{$_}++ } @{$actions_lr};

    return $actions_hr;
}

# }}}
# {{{ transform_l2h

sub transform_l2h :Export(:DEFAULT){
    my $lref = shift;
    my $href = {};

    map { $href->{$_}++ } @{$lref};

    return $href;
}

# }}}

1

__END__

